BasinMask Subroutine

private recursive subroutine BasinMask(basin, fdir, r, c)

search for cells included in the river basin

Arguments

Type IntentOptional Attributes Name
type(grid_integer), intent(inout) :: basin
type(grid_integer), intent(in) :: fdir
integer, intent(in) :: r
integer, intent(in) :: c

Source Code

RECURSIVE SUBROUTINE BasinMask &
!
(basin, fdir, r, c)

IMPLICIT NONE

TYPE(grid_integer),INTENT(IN) :: fdir
TYPE(grid_integer),INTENT(INOUT) :: basin
INTEGER, INTENT(in) :: r,c  

!------------------------------end of declaration -----------------------------

IF ( .NOT. IsOutOfGrid(r,c+1,fdir) ) THEN
    IF(fdir%mat(r,c+1)==W.AND. basin%mat(r,c+1)/=1) THEN
       basin%mat(r,c+1) = 1
       CALL BasinMask(basin,fdir,r,c+1) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r+1,c+1,fdir) ) THEN
    IF(fdir%mat(r+1,c+1)==NW .AND. basin%mat(r+1,c+1)/=1) THEN
       basin%mat(r+1,c+1) = 1
       CALL BasinMask(basin,fdir,r+1,c+1) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r+1,c,fdir) ) THEN
    IF(fdir%mat(r+1,c)==N .AND. basin%mat(r+1,c)/=1) THEN
       basin%mat(r+1,c) = 1
       CALL BasinMask(basin,fdir,r+1,c) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r+1,c-1,fdir) ) THEN
    IF(fdir%mat(r+1,c-1)==NE .AND. basin%mat(r+1,c-1)/=1) THEN
       basin%mat(r+1,c-1) = 1
       CALL BasinMask(basin,fdir,r+1,c-1)
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r,c-1,fdir) ) THEN
    IF(fdir%mat(r,c-1)==E .AND. basin%mat(r,c-1)/=1) THEN
       basin%mat(r,c-1) = 1
       CALL BasinMask(basin,fdir,r,c-1) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r-1,c-1,fdir) ) THEN
    IF(fdir%mat(r-1,c-1)==SE .AND. basin%mat(r-1,c-1)/=1) THEN
       basin%mat(r-1,c-1) = 1
       CALL BasinMask(basin,fdir,r-1,c-1) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r-1,c,fdir) ) THEN
    IF(fdir%mat(r-1,c)==S .AND. basin%mat(r-1,c)/=1) THEN
       basin%mat(r-1,c) = 1
       CALL BasinMask(basin,fdir,r-1,c) 
    END IF
END IF

IF ( .NOT. IsOutOfGrid(r-1,c+1,fdir) ) THEN
    IF(fdir%mat(r-1,c+1)==SW .AND. basin%mat(r-1,c+1)/=1) THEN
       basin%mat(r-1,c+1) = 1
       CALL BasinMask(basin,fdir,r-1,c+1) 
    END IF
END IF

END SUBROUTINE BasinMask